home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / System source / Event < prev    next >
Encoding:
Text File  |  1993-05-28  |  6.6 KB  |  241 lines  |  [TEXT/YERK]
  1. \ Modification  History
  2. \  4/16/84  NDI Version 1.0
  3. \  4/20/84  NDI Added ClickAction, replaces Middleman
  4. \  5/07/84  NDI now inits FEVENT, uses CALL:
  5. \  8/16/84  CBD MOUSE-EVT handles window directly
  6. \  8/26/84  CBD Deferred  methods for windows
  7. \ 10/12/84  CBD use objPtr for MenuBar
  8. \ 10/25/84  CBD Added click time for double-click use
  9. \ 11/11/84  CBD Added interval timer, wait, Mouse
  10. \  1/14/84  cbd Added modeless dialog support
  11. \ 12/08/85  cdn Fixed put: & click: methods in Mouse
  12. \               Added NULL-EVT-IDLE
  13. \  4/15/86  cdn Removed NULL-EVT-IDLE in favor of actW semaphore
  14. \  8/26/86  cdn Upgraded DISK-EVT to automatically mount volume
  15. \  8/31/88    rfl    added zoomWindow support
  16. \  3/22/90    rfl    multifinder compatible. removed call systemtask for nullevt
  17. \                as well as other things
  18. \  5/29/90    rfl handle bad disk mounts
  19. \  7/25/90    rfl    modified upd-evt and actv-evt for waitnextevent and non-multifinder
  20. \  9/30/90    rfl    next: doesn't need ^base; .pause now in nucleus
  21. \ 10.25.90    rfl    added deactivate and activate messages in multifinder event
  22. \ 12/21/90    rfl    getevent now needs nothing on the stack. This means there can
  23. \                never be more than one event object.
  24. \  1/31/90    rfl    font stuff moved to file
  25. \  6/08/91    rfl    high level events support
  26. \ 10/26/91    rfl    added abort load in (nevent) for either decho state
  27. \  5/07/93    rfl    added modifier key detection
  28. \  5/28/93    rfl    fixed hl-Evt to leave the advertised 0 on stack
  29.  
  30. Decimal
  31.  
  32. 'c (nevent1) -> nEvent        \ use as stub until Event is loaded
  33.  
  34. \ forward reference the menu bar
  35. 0 value MenuBar
  36.  
  37. \ max ticks for double click
  38. : dblTicks  $ 2f0 -base @  ;
  39.  
  40. hex
  41. create intSwap
  42.     2017 w,        \ move.l    (sp),d0
  43.     4840 w,        \ swap        d0
  44.     2e80 w,        \ move.l    d0,(sp)
  45. next,
  46. decimal
  47.  
  48. 0 variable theDlg
  49. 0 variable thePoint
  50.  
  51. \ ( gy:gx -- ly:lx )  convert a global point to a local point
  52. : G->L
  53.     thePoint !  thePoint +base
  54.     call GlobalToLocal  thePoint @  ;
  55.  
  56. : l->g thePoint ! thePoint +base call LocalToGlobal thePoint @ ;
  57.  
  58.  
  59. :CLASS Event  <Super X-Array
  60.  
  61.     Int        Evt
  62.     Var        Msg
  63.     Var        Time
  64.     Var        Loc
  65.     Int        Mods
  66.     Int        Mask
  67.     Var        Sleep
  68.     Var        MouseRgn
  69.  
  70.     :M  SLEEP:    put:  Sleep    ;M
  71.     :M  MouseRgn: put:  mouseRgn ;M
  72.     :M  TYPE:     get:  Evt         ;M
  73.     :M  MODS:     get:  Mods     ;M
  74.     :M  SET:      put:  Mask     ;M
  75.     :M  MSG:      get:  Msg      ;M
  76.  
  77.     \ ( -- mpoint )  leaves mouse loc as global toolbox Point
  78.     :M  WHERE:  get:  loc  ;M
  79.  
  80.     \ ( -- #secs )  Leave ticks
  81.     :M  WHEN:   get:  Time  ;M
  82.  
  83.     \ get the next event and exec its handler
  84.     \ ( -- b )  True if we should exit to caller
  85.     :M  NEXT:
  86.         getEvent
  87.         IF get: Evt ELSE 0 THEN
  88.         exec: super
  89.     ;M
  90.  
  91.     \ ( -- )  handle events until a key event occurs
  92.     :M  KEY: BEGIN  next: self UNTIL  ;M
  93.  
  94. ;CLASS
  95.  
  96. ' Event 'c fEvent !
  97.  
  98. \ define the mouse as an object
  99. :CLASS Mouse  <Super Object
  100.  
  101.     Var        Last        \ ticks when last click occurred
  102.     Var        Interval    \ ticks between clicks
  103.  
  104.     \ ( ticks -- )  update the click interval with current sysTicks value
  105.     :M  PUT:  dup get: last - put: interval  put: last  ;M
  106.  
  107.     \ ( -- type )  return the type of click that last occurred: 2=double
  108.     :M  CLICK:  get: interval dup 0> swap dblTicks < and
  109.         IF 2 ELSE 1 THEN  ;M
  110.  
  111.     \ return the mouse position as local point
  112.     :M  WHERE:  ?terminal drop where: fEvent  g->l unPack   ;M
  113.  
  114.     \ return the current state of the mouse - position and button
  115.     \ ( -- x y but )  button non-0 if down
  116.     :M  GET:   where: self  word0 call Button word0  ;M
  117.  
  118. ;CLASS
  119.  
  120. Mouse theMouse
  121.  
  122. \ return true if mouse button is still down
  123. : StillDown?  word0 call StillDown word0  ;
  124.  
  125. \ wait until a mouse click or key event
  126. : waitClick   BEGIN 10 ?event UNTIL ;
  127.  
  128. \ ( -- )  Desktop click handler
  129. : Desk  ;
  130.  
  131. \ ( wind -- )  System  click handler
  132. : Sys    +base abs: fEvent swap call SystemClick  ;
  133.  
  134. 0 value actW    \ Indentifies any active Yerk window which should be idled
  135.  
  136. \ ( -- 0 )  NULL, KEYUP, NETW, DRVR, application events
  137. : NULL-EVT 0 actW -dup IF idle: [ ] THEN    ;    \ If active YERK window, send idle
  138.  
  139. \ ( -- 0 )  mouse down event - perform a window-action
  140. : MOUSE-EVT
  141.     when: fEvent  put: theMouse    \ update click interval
  142.     where: fEvent  find-Window  swap
  143.     Select{    \  Region handlers
  144.         0  Is{  Drop  Desk           }End
  145.         1  Is{  Drop click: MenuBar  }End
  146.         2  Is{  Sys                  }End
  147.         3  Is{  content: [ ]         }End
  148.         4  Is{  drag: [ ]            }End
  149.         5  Is{  grow: [ ]            }End
  150.         6  Is{  Dup +Base  >R Word0 R> where: fEvent
  151.                 call TrackGoAway word0
  152.                 IF  close: [ ]
  153.                 ELSE  Drop THEN    }End
  154.         7  Is{ 7 swap zoom: [ ]  }End
  155.         8  Is{ 8 swap zoom: [ ]  }End
  156.     Default{  abort
  157.     }Select  0
  158. ;
  159.  
  160. \ checks to see if window belongs to the application - necessary for
  161. \ non-multifinder systems while calling waitnextevent
  162. : isAppWindow ( windPtr -- windPtr b) dup 108 + w@ 8 = ;
  163.  
  164. \ ( -- keywd modswd t OR f )  get key value
  165. : KEY-EVT 0 call frontwindow -base isappwindow swap drop
  166.     IF mods: fEvent  $ 100 and    \ command key?
  167.         IF  msg: fEvent  key: menuBar 0    \ check for menu selection
  168.         ELSE  msg: fEvent  mods: fEvent 1
  169.         THEN
  170.     ELSE 0
  171.     THEN  ;
  172.  
  173. \ ( -- 0 )  handle a disk insert event
  174. : DISK-EVT watchcurs
  175.     msg: fevent intSwap extend 0<
  176.     IF   word0 150 100 pack msg: fevent call dIBadMount i->l drop
  177.     ELSE 154 newPtr msg: fEvent over 22 + w!
  178.          dup fcall PBOffline drop
  179.          dup fcall PBMountVol drop
  180.          killPtr
  181.     THEN arrowcurs 0 ;
  182.  
  183. \ ( -- 0 )  cause window draw
  184. : UPD-EVT   msg: fEvent -base isAppWindow
  185.     IF draw: [ ]  ELSE drop THEN 0  ;
  186.  
  187. \ ( -- 0 )  activate, draw window
  188. : ACTV-EVT
  189.     msg: fEvent -base    isAppWindow \ get the window object
  190.     IF mods: fEvent 01 and
  191.         IF    enable: [ ]
  192.         ELSE  disable: [ ]
  193.         THEN
  194.     ELSE drop
  195.     THEN  0  ;
  196.  
  197. true value inForeGround
  198. nullcfa vect resume
  199. nullcfa vect suspend
  200. nullcfa vect cvtClip
  201. nullcfa vect mouseMoved
  202. 'c drop vect appleEvt
  203. 'c drop vect hlevt
  204.  
  205. 0 value saveWind
  206.  
  207. ( -- 0)
  208. : OS-Evt
  209.     msg: fevent $ 1000000 and
  210.     IF    msg: fevent 1 and
  211.         IF      saveWind -> actw enable:  actw  true -> inForeGround resume
  212.         ELSE  actw -> saveWind disable: actw false -> inForeGround suspend
  213.         THEN
  214.         msg: fevent 2 and IF cvtClip THEN
  215.     ELSE msg: fevent $ FA000000 and
  216.         IF mouseMoved THEN
  217.     THEN 0 ;
  218.  
  219. ( -- 0) \ High level events
  220. : HL-Evt where: fevent msg: fevent 'type aevt =
  221.     IF AppleEvt ELSE hlEvt THEN 0 ;
  222.  
  223.  
  224. : key     key: fEvent  drop $ ff and ;
  225. 'c key ' abort 16 + !
  226.  
  227. : rekey   'c key  -> keyvec ;
  228.  
  229. \ these check if a particular modifier key is down. They do not check
  230. \  if the particular key is the ONLY modifier key down.
  231. : command? ( -- b) mods: fevent $  100 and 0> ;    \ command key down?
  232. : shift?   ( -- b) mods: fevent $  200 and 0> ;    \ is the shift key held down?
  233. : ctl?        ( -- b) mods: fevent $ 1000 and 0> ;
  234. : option?  ( -- b) mods: fevent $  800 and 0> ;    \ you get the idea
  235.  
  236. \ put it nEvent later - allow background loading and a way to abort
  237. : (nEvent) next: fevent
  238.     IF 2drop \ decho
  239.        .pause key 32 <> IF abort THEN
  240.     THEN ;
  241.